home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / spectr20.zip / MAKCOEF.FOR < prev    next >
Text File  |  1992-04-22  |  6KB  |  197 lines
  1. *    MAKCOEF.FOR
  2.  
  3. *    Create a binary data file containing transformation
  4. *    coefficients for the spectrum routine.
  5.  
  6. *    David E. Hess
  7. *    Fluid Flow Group - Process Measurements Division
  8. *    Chemical Science and Technology Laboratory
  9. *    National Institute of Standards and Technology
  10. *    April 15, 1992
  11.  
  12. *    This routine reads an ASCII input data file and rewrites
  13. *    the data into a binary data file which can be
  14. *    processed by the SPECTRUM calculation program. The routine
  15. *    first prompts the user for information necessary to create the
  16. *    file header and then the rewriting procedure begins. Extensive
  17. *    error checking is included in an attempt to make the
  18. *    transformation process as painless as possible. Refer to the
  19. *    section in the user's manual for further details.
  20.  
  21. *    IFMAX and NUMCON in the parameter statement below MUST match
  22. *    the values for IFMAX and NUMCON in the spectrum routine.
  23.  
  24. *            File Extensions
  25. *            ---------------
  26. *    .ASC - ASCII input data file (no header, just numbers)
  27. *    .DAT - Binary coefficient file (with file header)
  28.  
  29. *            Header Information
  30. *            ------------------
  31. *    NSTART    : coefficient sets will be consecutively
  32. *          associated to files starting from this #
  33. *    NUMCON    : # of coefficients in polynomial (must be 5)
  34. *    NUMSETS    : # of sets of coefficients in data file
  35.  
  36.     IMPLICIT    REAL*4 (A-H,O-Z), INTEGER*2 (I-N)
  37.     PARAMETER    (NUMI=2,NUMO=3,NMAX=16384,IFMAX=100)
  38.     PARAMETER    (NUMCON=5)
  39.     LOGICAL*1    ONECHAN,TWOCHAN
  40.     REAL*4        CONST[ALLOCATABLE](:,:)
  41.     CHARACTER    INSFX *4 /'.ASC'/, OSFX1 *7 /'CON.DAT'/
  42.     CHARACTER    OSFX2 *8 /'CON2.DAT'/
  43.     CHARACTER*1    FIRST,LETTER
  44.     CHARACTER*4    INNAM
  45.     CHARACTER*8    INFIL,OUTFIL
  46.     CHARACTER*9    OUTFL2
  47.  
  48. *    Get the first letter.
  49.  
  50. 10    WRITE (*,'(/1X,A/1X,A\)') 'Enter first letter of data file to',
  51.      +                 'which these coefficients will be associated : '
  52.     READ (*,'(A)') FIRST
  53.     IF (ICHAR(FIRST) .GE. 97 .AND. ICHAR(FIRST) .LE. 122) THEN
  54.       IHOLD=ICHAR(FIRST)-32
  55.       FIRST=CHAR(IHOLD)
  56.     ENDIF
  57.     IF (ICHAR(FIRST) .LT. 65 .OR. ICHAR(FIRST) .GT. 90) THEN
  58.       WRITE (*,'(1X,A/)') 'Enter an alphabetic character (A-Z).'
  59.       GO TO 10
  60.     ENDIF
  61.  
  62. *    Get channel #.
  63.  
  64. 20    WRITE (*,'(/1X,A\)')
  65.      +     'Are these coefficients for channel (1 or 2) : '
  66.     READ (*,*) ICHANS
  67.     ONECHAN=(ICHANS .EQ. 1)
  68.     TWOCHAN=(ICHANS .EQ. 2)
  69.     IF (.NOT. ONECHAN .AND. .NOT. TWOCHAN) GO TO 20
  70.  
  71. *    Get # of sets of coefficients.
  72.  
  73. 30    WRITE (*,'(/1X,A\)') 'Enter # of sets of coefficients : '
  74.     READ (*,*) NUMSETS
  75.     IF (NUMSETS .GT. IFMAX) THEN
  76.       WRITE (*,'(/1X,A,I3)') 
  77.      +      'Current maximum number of sets = ',IFMAX
  78.       GO TO 30
  79.     ENDIF
  80.  
  81. *    Get starting file number to associate coefficients to.
  82.  
  83.     WRITE (*,'(/1X,A\)') 'Enter starting file number : '
  84.     READ (*,*) NSTART
  85.     IF (NUMSETS+NSTART-1 .GT. IFMAX) THEN
  86.       WRITE (*,'(/1X,A/1X,A/1X,A,I3)')
  87.      +      'Your choice of number of sets and',
  88.      +      'starting file number must satisfy',
  89.      +      'NUMSETS + NSTART - 1 <= ',IFMAX 
  90.       GO TO 30
  91.     ENDIF
  92.  
  93. *    Get input file name.
  94.  
  95. 40    WRITE (*,'(/1X,A\)') 'Enter ASCII input file name (4 chars) : '
  96.     READ (*,'(A)') INNAM
  97.  
  98. *    Convert to uppercase and check first character alphabetic.
  99.  
  100.     DO J=4,1,-1
  101.       LETTER=INNAM(J:J)
  102.       IF (ICHAR(LETTER) .GE. 97 .AND. ICHAR(LETTER) .LE. 122) THEN
  103.         IHOLD=ICHAR(LETTER)-32
  104.         LETTER=CHAR(IHOLD)
  105.         INNAM(J:J)=LETTER
  106.       ENDIF
  107.     ENDDO
  108.     IF (ICHAR(LETTER) .LT. 65 .OR. ICHAR(LETTER) .GT. 90) THEN
  109.       WRITE (*,'(/1X,A,A,A/1X,A,A,A/1X,A)') 
  110.      +      'Filename ',INNAM,' began with',
  111.      +      'the nonalphabetic character ',LETTER,'.',
  112.      +      'Re-enter the filename correctly.'
  113.       GO TO 40
  114.     ENDIF
  115.  
  116.     INFIL=INNAM // INSFX
  117.     IF (ONECHAN) OUTFIL=FIRST // OSFX1
  118.     IF (TWOCHAN) OUTFL2=FIRST // OSFX2
  119.  
  120. *    Put message on screen.
  121.  
  122.     WRITE (*,'(/////////////////////10X,A,A)')
  123.      +    'C O E F F I C I E N T   F I L E   ',
  124.      +    'C R E A T I O N   U T I L I T Y'
  125.     IF (ONECHAN)
  126.      +       WRITE (*,'(/25X,''Creating '',A,'' now.'')') OUTFIL
  127.     IF (TWOCHAN)
  128.      +       WRITE (*,'(/25X,''Creating '',A,'' now.'')') OUTFL2
  129.  
  130. *    Open input ASCII file.
  131.  
  132.     OPEN (NUMI,FILE=INFIL,STATUS='OLD',ERR=100)
  133.  
  134. *    Open output data file and write header.
  135.  
  136.     IF (ONECHAN) OPEN (NUMO,FILE=OUTFIL,STATUS='UNKNOWN',
  137.      +        ACCESS='SEQUENTIAL',FORM='BINARY',ERR=110)
  138.     IF (TWOCHAN) OPEN (NUMO,FILE=OUTFL2,STATUS='UNKNOWN',
  139.      +        ACCESS='SEQUENTIAL',FORM='BINARY',ERR=110)
  140.     WRITE (NUMO) NUMSETS,NSTART
  141.  
  142. *    Allocate space for CONST array.
  143.  
  144.     ALLOCATE (CONST(NUMSETS,NUMCON), STAT=IERR)
  145.     IF (IERR .NE. 0)
  146.      +     STOP 'Problem allocating storage for CONST.  Aborting ...'
  147.  
  148. *    Display header information.
  149.  
  150.     WRITE (*,'(/25X,A,I3)')   '# sets of coeffs = ',NUMSETS
  151.     WRITE (*,'(25X,A,I1)')    '# coeffs in each set = ',NUMCON
  152.     WRITE (*,'(25X,A,I3)')    '# of starting file = ',NSTART
  153.  
  154.     READ (NUMI,*,ERR=120,END=140)
  155.      +         ((CONST (I,J), J=1,NUMCON), I=1,NUMSETS)
  156.     WRITE (NUMO,ERR=130)
  157.      +         ((CONST (I,J), J=1,NUMCON), I=1,NUMSETS)
  158.  
  159.     CLOSE (NUMI,STATUS='KEEP')
  160.     CLOSE (NUMO,STATUS='KEEP')
  161.  
  162.     WRITE (*,'( )')
  163.     STOP '                        Program terminated successfully.'
  164.  
  165. *    Problem opening input ASCII file.
  166.  
  167. 100    WRITE (*,'(/25X,A/)') 'Problem opening input ASCII file.'
  168.     STOP '                       Program terminated unsuccessfully.'
  169.  
  170. *    Problem opening output data file.
  171.  
  172. 110    WRITE (*,'(/25X,A/)') 'Problem opening output data file.'
  173.     STOP '                       Program terminated unsuccessfully.'
  174.  
  175. *    Problem reading input ASCII file.
  176.  
  177. 120    WRITE (*,'(/25X,A/)') 'Problem reading input ASCII file.'
  178.     CLOSE (NUMI,STATUS='KEEP')
  179.     CLOSE (NUMO,STATUS='KEEP')
  180.     STOP '                       Program terminated unsuccessfully.'
  181.  
  182. *    Problem writing output data file.
  183.  
  184. 130    WRITE (*,'(/25X,A/)') 'Problem writing output data file.'
  185.     CLOSE (NUMI,STATUS='KEEP')
  186.     CLOSE (NUMO,STATUS='KEEP')
  187.     STOP '                       Program terminated unsuccessfully.'
  188.  
  189. *    Problem : reached end of file marker reading input ASCII file.
  190.  
  191. 140    WRITE (*,'(/25X,A/)') 'Problem : reached end of file marker',
  192.      +                     ' reading input ASCII file.'
  193.     CLOSE (NUMI,STATUS='KEEP')
  194.     CLOSE (NUMO,STATUS='KEEP')
  195.     STOP '                       Program terminated unsuccessfully.'
  196.     END
  197.